home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / editors / mutt / me2s_pl7.zoo / mu_edit2 / mc2 / mc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-08-26  |  14.4 KB  |  475 lines
  1. /*
  2.  * mc.c : the Mutt compiler
  3.  *  Craig Durland 6/87, modified in late '91 for Mutt2
  4.  */
  5.  
  6. /* Copyright 1990, 1991, 1992 Craig Durland
  7.  *   Distributed under the terms of the GNU General Public License.
  8.  *   Distributed "as is", without warranties of any kind, but comments,
  9.  *     suggestions and bug reports are welcome.
  10.  */
  11.  
  12. static char what[] = "@(#)Mutt2 compiler v2.1 2/2/92";
  13. #define WHAT (&what[4])
  14.  
  15. #include <stdio.h>
  16. #include <os.h>
  17. #include "mc.h"
  18. #include "opcode.h"
  19. #include "mm.h"
  20.  
  21. extern address entrypt;        /* in code.c */
  22. extern char *malloc(), *strcpy(), *new_ext(), *spoof(), *savestr();
  23. extern int xtn, msize, omsize;
  24. extern int32 atoN();
  25. extern MuttCmd muttcmds[];
  26. extern unsigned int codesize();
  27. extern void doc(), dumpcode(), pilefile();
  28.  
  29. char ebuf[MAXSTRLEN+5], *muttfile = "", *include_list[10];
  30. FILE *lstfile = NULL, *srcfile;
  31. int errors = 0, warnings = 0, srcline = 0;
  32.  
  33. main(argc,argv) char *argv[];
  34. {
  35.   extern char *optarg, optltr;        /* in argh.c */
  36.   extern int no_warn, no_gripe;        /* in supp.c */
  37.  
  38.   char buf[90], *ptr = NULL, *tfname = NULL;
  39.   int j = 0, list = FALSE, x, stats = FALSE, quiet = FALSE;
  40.  
  41.   while ( (x = argh(argc,argv,"I:lst:vq:")) )
  42.     switch (x)
  43.     {
  44.       case 2: ptr = optarg; break;
  45.       case 1:
  46.     switch (optltr)
  47.     {
  48.       case 'I': include_list[j++] = optarg; break;
  49.       case 'l': list = TRUE;    break;
  50.       case 's': stats = TRUE;    break;
  51.       case 't': tfname = optarg;    break;
  52.       case 'v':
  53.         printf("%s copyright 1987-92 Craig Durland\n",WHAT);
  54.         exit(0);
  55.       case 'q':            /* quiet */
  56.         x = atoi(optarg);
  57.         quiet    = x & 1;
  58.         no_gripe = x & 2;
  59.         no_warn  = x & 4;
  60.         break;
  61.     }
  62.     }
  63.   include_list[j] = NULL;
  64.  
  65.   if (!quiet) printf("%s\n",WHAT);
  66.  
  67.   if (ptr == NULL) { doc(); exit(1); }
  68.  
  69.   if (list)
  70.   {
  71.     new_ext(buf,ptr,".lst");
  72.     if ((lstfile = fopen(buf,"w")) == NULL) bitch("Can't open list file.");
  73.   }
  74.  
  75.   if (tfname) load_ext_token_table(tfname);    /* external token file */
  76.  
  77.   init_code_generater();
  78.  
  79.   new_ext(buf,ptr,".mut");
  80.   pilefile(buf,FALSE); finishup();
  81.  
  82.   if (errors == 0) dumpcode(ptr);
  83.   spoof(ebuf,"%d Errors.  %d Warnings. %u bytes of code.",
  84.     errors,warnings,codesize());
  85.  
  86.   if (stats) dump_stats(stdout);
  87.   if (!quiet) puts(ebuf);
  88.  
  89.   if (lstfile) { fprintf(lstfile,"\n%s\n",ebuf); fclose(lstfile); }
  90.   exit(errors);
  91. }
  92.  
  93. void doc()
  94. {
  95.   dump_doc(
  96.   "MC2 [options] sourcefile[.MUT]",
  97.   "options: ",
  98.   " -I dir: An alternate directory for include files.  One dir per -I",
  99.   " -l : Assembler output with source comments.  Put into sourcefile.LST",
  100.   " -q <bits> : quiet some messages",
  101.   " -s : Obscure compiler stats",
  102.   " -t tokenfile : tokenfile.TOK contains X-tokens",
  103.   " -v : Display the version of the compiler",
  104.   "Compiled code is put into sourcefile.MCO",
  105.   (char *)NULL);
  106. }
  107.  
  108. extern char *catstrs();
  109.  
  110.     /* open a file, search path_list if necessary */
  111. FILE *flopen(name,path_list,mode) char *name, *path_list[], *mode;
  112. {
  113.   char buf[300];
  114.   FILE *fptr;
  115.   int j;
  116.  
  117.   if ((fptr = fopen(name,mode))) return fptr;
  118.   for (j = 0; path_list[j]; j++)
  119.     if ((fptr = fopen(catstrs(buf,path_list[j],"/",name,(char *)NULL),mode)))
  120.       return fptr;
  121.   return NULL;
  122. }
  123.  
  124. void pilefile(fname,search) char *fname;
  125. {
  126.   char fn[100], *ptr = muttfile;
  127.   FILE *sf = srcfile;
  128.   int sline = srcline;
  129.  
  130.   srcfile = search ? flopen(fname,include_list,"r") : fopen(fname,"r");
  131.   if (srcfile == NULL) bitch(spoof(ebuf,"Can't open %s.",fname));
  132.   muttfile = strcpy(fn,fname); srcline = 0;
  133.   getsrc();    /* prime scan() */
  134.   while (compile()) ;
  135.   muttfile = ptr; srcline = sline;
  136.   fclose(srcfile); srcfile = sf;
  137. }
  138.  
  139. /* ******************************************************************** */
  140. /* ********************* the compiler ********************************* */
  141. /* ******************************************************************** */
  142.  
  143. extern address getpgm(), pcaddr();
  144. extern int ddone_label, btv;
  145. extern MMDatum *getconst();
  146.  
  147. char token[257], temp[257];
  148. int breaklabel = -1, contlabel = -1;
  149. unsigned int class = VOID;
  150. MMDatum rv, *vtr;
  151.  
  152. compile()
  153. {
  154.   static int clevel = -1, indefun = FALSE;
  155.  
  156.   int l1, ldone, t,z;
  157.   unsigned int lastclass;
  158.  
  159.   clevel++;
  160.   lastclass = class; get_token();
  161.   switch(class)
  162.   {
  163.     case SEOF:    clevel--; return FALSE;    /* hit EOF */
  164.     case STRING:  gostr(RVSTR,token);    break;
  165.     case NUMBER:  gonumx(atoN(token));    break;
  166.     case BOOLEAN: gonum8(RVBOOL,btv);    break;
  167.     case TOKEN:   genvar(token,FALSE);    break;
  168.     case DELIMITER:
  169.       switch (*token)
  170.       {
  171.     case '{':                         /* { ... } */
  172.       while (TRUE)
  173.       {
  174.         lookahead();
  175.         if (class == DELIMITER)
  176.           if (*token == '}') break;
  177.           else if (*token == '{') bitch("Can't nest pgms.");
  178.         class = lastclass; compile(); lastclass = class;
  179.       }
  180.       get_token();        /* suck up } */
  181.       class = lastclass; 
  182.       break;
  183.     case '(':                         /* ( ... ) */
  184.       lookahead();
  185.       if (class == DELIMITER && *token == ')')    /* () */
  186.         { class = EMPTY; goto endexp; }
  187. /*class = lastclass;*/
  188.       get_token();
  189.       switch (class)
  190.       {
  191.         case STRING:  gostr(RVSTR,token);  goto endexp;
  192.         case NUMBER:  gonumx(atoN(token)); goto endexp;
  193.         case BOOLEAN: gonum8(RVBOOL,btv);  goto endexp;
  194.         case TOKEN:      break;
  195.         default:
  196.           bitch(spoof(ebuf,
  197.         "Wanted token, string, number or boolean, got %s.",token));
  198.       }
  199.       if ((t = lookup(token,muttcmds,msize)) != -1)
  200.       {
  201.         class = lastclass;
  202.         switch (t)
  203.         {
  204.           case 64:                      /* (include file) */
  205.         get_token();
  206.         if (class != TOKEN && class != STRING)
  207.           bitch("include requires token or string.");
  208.         clevel--; class = include(token); clevel++;
  209.         goto done;    /* end of this line !!! sleaze */
  210.           case 23: class = comp_if(lastclass); break;    /* (if ...) */
  211.           case 5:  class = comp_while();  break;         /* (while ...) */
  212.           case 76: class = comp_for();    break;           /* (for ...) */
  213.                 case 1:  class = comp_cond();   break;          /* (cond ...) */
  214.           case 4:  class = comp_switch(); break;        /* (switch ...) */
  215.           case 2:                    /* (defun name pgm) */
  216.         if (clevel != 0) moan("Can't nest defuns.");
  217.         indefun = TRUE;
  218.         defun();
  219.         indefun = FALSE; class = VOID;
  220.         break;
  221.           case 8: case 6:         /* (label label-name) (goto label) */
  222.         get_token();
  223.         if (class != TOKEN && class != STRING)
  224.           bitch("Label must be token or string.");
  225.         if (!indefun)
  226.           moan("Labels and gotos can only be used inside defuns.");
  227.         if ((z = get_named_label(token)) == -1)
  228.             z = gen_named_label(token);
  229.         if (t == 6) { gojmp(JMP,z); class = VOID; }        /* goto */
  230.         else                           /* label */
  231.         {
  232.           stufflabel(z);
  233.           class = UNKNOWN;    /* can get here from anywhere */
  234.         }
  235.         break;
  236.           case 7:                         /* (break) */
  237.         if (breaklabel == -1)
  238.             { moan("break not allowed here."); break; }
  239.         gojmp(JMP,breaklabel); class = VOID;
  240.         break;
  241.           case 71:                          /* (continue) */
  242.         if (contlabel == -1)
  243.             { moan("continue not allowed here."); break; }
  244.         gojmp(JMP,contlabel); class = VOID;
  245.         break;
  246.           case  9:                          /* (done) */
  247.         if (ddone_label == -1) genop(DONE); 
  248.         else               gojmp(JMP,ddone_label);
  249.         class = VOID;
  250.         break;
  251.           case 16: genop(HALT);   class = VOID;   break;      /* (halt) */
  252.           case 29: genop(RVVOID); class = VOID;   break;   /* (novalue) */
  253.           case 42: genop(NARGS);  class = NUMBER; break;     /* (nargs) */
  254.           case 43:                         /* (arg n) */
  255.         compile(); type_check(NUMBER,0); genop(ARG); class = UNKNOWN;
  256.             break;
  257.           case 15:                       /* (push-args n) */
  258.         compile(); type_check(NUMBER,0); genop(PUSHARGS);
  259.         class = PUSHEDARGS;
  260.             break;
  261.           case 17:                      /* (push-arg exp) */
  262.         compile(); genop(SHOVERV); class = PUSHEDARGS;
  263.             break;
  264.           case 0:                        /* (!= val val) */
  265.         compile(); z = class;
  266.         checkit("!=",STRING,BOOLEAN,NUMBER,0);
  267.         pushpush(); compile();
  268.         if (z != UNKNOWN) type_check(z,0);        /* yukk!!! */
  269.         genop(CMP); genop(NOT); class = BOOLEAN;
  270.         break;
  271.           case 12:                       /* (== val val ... ) */
  272.         compile(); z = class;
  273.         checkit("==",STRING,BOOLEAN,NUMBER,0);
  274.         pushpush(); compile();
  275.         if (z != UNKNOWN) type_check(z,0);    /* yukk!!! */
  276.         if (!gaze_ahead(STRING,BOOLEAN,NUMBER,0))   /* (== val val) */
  277.             genop(CMP);
  278.         else            /* (== val val val [...]) */
  279.         {
  280.           l1 = genlabel();
  281.           do
  282.           {
  283.             genop(DUP); genop(CMP);
  284.             if (!gaze_ahead(STRING,BOOLEAN,NUMBER,0)) break;
  285.             gojmp(JMPFALSE,l1); compile();
  286.             if (z != UNKNOWN) type_check(z,0);    /* yukk!!! */
  287.           } while (TRUE);
  288.           stufflabel(l1); genop(POP);
  289.         }
  290.         class = BOOLEAN;
  291.         break;
  292.           case 21:                /* (remove-elements object n z) */
  293.         gonum16(PUSHTOKEN,REMOVE_ELS);
  294.         compile(); checkit("remove-elements", LIST,STRING,0); /* !!!ick */
  295.             /* !!!??? can't be a string constant! */
  296.           genop(SHOVERV);
  297.         compile(); type_check(NUMBER,0); genop(SHOVERV);
  298.         compile(); type_check(NUMBER,0); genop(SHOVERV);
  299.         genop(DOOP); class = VOID;
  300.         break;
  301.           case 18:         /* (insert-object object n new-object ...) */
  302.         gonum16(PUSHTOKEN,INSERT_OBJ);
  303.         compile(); checkit("insert-object", LIST,STRING,0); /* !!!ick */
  304.           genop(SHOVERV);
  305.         compile(); type_check(NUMBER,0); genop(SHOVERV);
  306.         while (gaze_ahead(LIST,STRING,NUMBER,0))
  307.             { compile(); genop(SHOVERV); } 
  308.         
  309.         genop(DOOP);
  310.         class = UNKNOWN;    /* !!!Not really - its STRING or LIST */
  311.         break;
  312.           case 24:                  /* (extract-element object n) */
  313.         gonum16(PUSHTOKEN,EXTRACT_EL);
  314.         compile();
  315.         checkit("extract-element", LIST,STRING,0); /* !!!ick */
  316.             /* !!!??? can't be a string constant! */
  317.           genop(SHOVERV);
  318.         compile(); type_check(NUMBER,0); genop(SHOVERV);
  319.         genop(DOOP); class = UNKNOWN;
  320.         break;
  321.           case 25:               /* (extract-elements object n z) */
  322.         gonum16(PUSHTOKEN,EXTRACT_ELS);
  323.         compile();
  324.         checkit("extract-elements", LIST,STRING,0); /* !!!ick */
  325.             /* !!!??? can't be a string constant! */
  326.           genop(SHOVERV);
  327.         compile(); type_check(NUMBER,0); genop(SHOVERV);
  328.         compile(); type_check(NUMBER,0); genop(SHOVERV);
  329.         genop(DOOP);
  330.         class = UNKNOWN;    /* !!!Not really - its STRING or LIST */
  331.         break;
  332.           case 19:                      /* (length-of object) */
  333.             compile();    /* get object - can be anything */
  334.         genop(LEN_OF);
  335.         class = NUMBER;
  336.         break;
  337.           case 20:                /* (convert-to type object) */
  338.         compile(); type_check(NUMBER,0); genop(SHOVERV);  /* type */
  339.             compile();    /* get object - can be anything */
  340.         genop(CONVERT_TO);
  341.         class = UNKNOWN; /* !!!I can (sometimes) figure out the type */
  342.             /* !!! do some more checking here */
  343.         break;
  344.           case 28:                           /* (not) */
  345.         compile(); type_check(BOOLEAN,0); genop(NOT); class = BOOLEAN;
  346.         break;
  347.           case 3:  opmath(ADD); break;         /* (+ num num ...) */
  348.           case 67: opmath(SUB); break;         /* (- num num ...) */
  349.           case 65: opmath(MUL); break;         /* (* num num ...) */
  350.           case 69: opmath(DIV); break;         /* (/ num num ...) */
  351.           case 63: opeq(ADD);   break;      /* (+= var num [num ...]) */
  352.           case 68: opeq(SUB);   break;      /* (-= var num [num ...]) */
  353.           case 66: opeq(MUL);   break;      /* (*= var num [num ...]) */
  354.           case 70: opeq(DIV);   break;      /* (/= var num [num ...]) */
  355.           case 11: case 14:               /* (< num num), (>= num num) */
  356.         compile(); z = class;
  357.         checkit("< or >=",NUMBER,0); pushpush();
  358.         compile();
  359.         if (z != UNKNOWN) type_check(z,0);    /* yukk!!! */
  360.         genop(LT);
  361.         if (t == 14) genop(NOT);    /* (x >= y) == !(x < y) */
  362.         class = BOOLEAN;
  363.         break;
  364.           case 10: case 13:               /* (<= num num), (> num num) */
  365.         compile(); z = class;
  366.         checkit("<= or >",NUMBER,0); pushpush();
  367.         compile();
  368.         if (z != UNKNOWN) type_check(z,0);    /* yukk!!! */
  369.         genop(LTE);
  370.         if (t == 13) genop(NOT);    /* (x > y) == !(x <= y) */
  371.         class = BOOLEAN;
  372.         break;
  373.           case 81:                       /* (or bool ...) */
  374.         z = JMPTRUE;
  375.           andor:
  376.         ldone = genlabel();
  377.         while (TRUE)
  378.         {
  379.           compile(); type_check(BOOLEAN,0);
  380.           lookahead(); if (class == DELIMITER && *token == ')') break;
  381.           gojmp(z,ldone);
  382.         }
  383.         stufflabel(ldone);
  384.         class = BOOLEAN;
  385.         break;
  386.           case 80: z = JMPFALSE; goto andor;     /* (and bool bool ...) */
  387.           case 26: genop(ASKUSER); break;              /* (ask-user) */
  388.           case 78: floc(); break;             /* (floc fcn-name) */
  389.           case 79: loc();  break;              /* (loc var-name) */
  390.           case 72:                       /* (pointer var) */
  391.         isvarok(clevel,class); pointer(indefun); class = lastclass;
  392.         break;
  393.           case 73:                  /* (array type name subs) */
  394.         isvarok(clevel,class);
  395.         array(indefun ? LOCAL : GLOBAL,FALSE); class = lastclass;
  396.         break;
  397.           case 62:                    /* (bool var [var ...]) */
  398.         t = BOOLEAN;
  399.         defvar:
  400.             isvarok(clevel,class); vdeclare(t,indefun); class = lastclass;
  401.         break;
  402.           case 75: t = INT8;  goto defvar;        /* (byte var [var ...]) */
  403.           case 61: t = INT16; goto defvar; /* (small-int var [var ...]) */
  404.           case 31: t = INT32; goto defvar;         /* (int var [var ...]) */
  405.           case 60:                /* (string name [name ...]) */
  406.         t = STRING; goto defobject;
  407.           case 27:                  /* (list name [name ...]) */
  408.         t = LIST;
  409.           defobject:
  410.         isvarok(clevel,class); 
  411.         do
  412.         {
  413.           get_token();
  414.           if (class != TOKEN)
  415.             bitch(spoof(ebuf,"%s is not a var name.",token));
  416.           z = addvar(token, t, 0, (indefun ? LOCAL : GLOBAL));
  417.           if (indefun) genobj(CREATE_OBJ, LOCAL, t, voffset(z));
  418.           lookahead();
  419.         } while (class == TOKEN);
  420.  
  421.         class = lastclass;
  422.         break;
  423.           case 77:               /* (const name val name val ...) */
  424.         do
  425.         {
  426.           get_token();
  427.           if (class != TOKEN)
  428.             bitch(spoof(ebuf,"%s is not a const name.",token));
  429.           strcpy(temp,token);
  430.           get_token(); rv.type = class;
  431.           switch (class)
  432.           {
  433.             case NUMBER:  rv.val.num = atoN(token); break;
  434.             case BOOLEAN: rv.val.num = btv; break;
  435.             case STRING:  rv.val.str = savestr(token); break;
  436.             case TOKEN:
  437.               if (vtr = getconst(token)) { rv = *vtr; break; }
  438.               /* else fall though and error */
  439.             default:
  440.               moan(spoof(ebuf,"Invalid const type: %s",token));
  441.               rv.type = BOOLEAN;
  442.           }
  443.           add_const(temp,&rv);
  444.           lookahead();
  445.         } while (class == TOKEN);
  446.         class = lastclass;
  447.         break;
  448.           default: moan(spoof(ebuf,"Compiler is confused by %s.",token));
  449.         }
  450.         goto endexp;
  451.       }
  452.       if (other_Mutt_cmd(token)) goto endexp;
  453.       if (varcompile(TRUE)) goto endexp;
  454.       if ((t = getpgm(token)) != NIL) goaddr(PUSHADDR,t,token);
  455.       else 
  456.         if (-1 != (t = lookup_ext_token_by_name(token))) gonum16(PUSHXT,t);
  457.         else gostr(PUSHNAME,token);
  458.       vargs(); genop(DOOP); class = UNKNOWN;
  459.   endexp:
  460.       lastclass = class; get_token();
  461.       if (class != DELIMITER || *token != ')')
  462.         bitch(spoof(ebuf,"Wanted ) got %s.",token));
  463.       class = lastclass;
  464.       break;
  465.     default:
  466.       bitch(spoof(ebuf,"Invalid delimiter: %s  ?not enough args?",token));
  467.       }
  468.       break;
  469.     default: bitch(spoof(ebuf,"I don't reconize %s!",token));
  470.   }
  471. done:
  472.   clevel--;
  473.   return TRUE;
  474. }
  475.